home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / primops / m68low.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  8.9 KB  |  254 lines
  1. (herald m68low
  2.   (env (make-empty-early-binding-locale 'nil) constants primops arith locations))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. (define-constant (return . args)
  28.   (ignore args)
  29.   (lap ()                           
  30.     (neg .l NARGS)             ; !!
  31.     (move .l (@r sp) tp)
  32.     (jmp (@r tp))))
  33.                  
  34. (declare simplifier return simplify-values)
  35.  
  36. (define-constant (receive-values recipient thunk)
  37.   (ignore recipient thunk)
  38.   (lap ()
  39.     (move .l A1 (@-r SP))                       ; push "recipient"
  40.     (pea (label receiver))
  41.     (move .l A2 P)                      ; prepare to call thunk
  42.     (move .l ($ 1) NARGS)               ; thunk takes no arguments
  43.     (jmp (*d@nil slink/icall))))
  44.  
  45. (lap-template (1 0 -1 t stack handle-receiver)
  46. receiver
  47.     (move .l (d@r SP 4) P)              ; prepare to call recipient
  48.     (add .l ($ 8) SP)                   ; restore continuation
  49.     (neg .l NARGS)                      ; !!
  50.     (jmp (*d@nil slink/icall))
  51. handle-receiver
  52.   (move .l nil-reg AN)
  53.   (rts))
  54.  
  55. (declare simplifier receive-values simplify-receive-values)
  56.  
  57. (define-constant make-pointer        ; extend and number of bytes
  58.   (primop make-pointer ()                                        
  59.     ((primop.generate self node)
  60.      (generate-make-pointer node))
  61.     ((primop.type self node)
  62.      '#[type (proc #f (proc #f top) top fixnum)])))
  63. ;     '#[type (proc #f (proc #f top) extend fixnum)])))
  64.  
  65. (define-constant task-ref
  66.   (primop task-ref ()
  67.     ((primop.generate self node)
  68.      (generate-task-ref node))))
  69.  
  70. (define-constant set-task-ref
  71.   (primop set-task-ref ()
  72.     ((primop.side-effects? self) t)
  73.     ((primop.generate self node)
  74.      (generate-set-task-ref node))))
  75.  
  76. (define-constant slink-ref
  77.   (primop slink-ref ()
  78.     ((primop.generate self node)
  79.      (generate-slink-ref node))))
  80.  
  81. (define-constant set-slink-ref
  82.   (primop set-slink-ref ()
  83.     ((primop.side-effects? self) t)
  84.     ((primop.generate self node)
  85.      (generate-set-slink-ref node))))
  86.  
  87. (define-constant system-global
  88.   (object (lambda (i) (slink-ref i))
  89.     ((setter self)
  90.      (lambda (i val) (set-slink-ref i val)))))
  91.  
  92. (define-constant process-global
  93.   (object (lambda (i) (task-ref i))
  94.     ((setter self)
  95.      (lambda (i val) (set-task-ref i val)))))
  96.  
  97. (define-constant stack-pointer
  98.   (primop stack-pointer ()
  99.     ((primop.generate self node)
  100.      (generate-stack-pointer node))))
  101.  
  102. ;; template junk, see template.doc
  103.  
  104. (define-constant template-enclosing-object
  105.   (primop template-enclosing-object ()
  106.     ((primop.generate self node)
  107.      (receive (source target rep) (one-arg-primitive node)
  108.          (generate-move source target)
  109.          (emit m68/clr .l SCRATCH)
  110.          (emit m68/move .w (reg-offset target -4) SCRATCH) ; offset field in bytes
  111.          (emit m68/sub .l SCRATCH target) 
  112.          (mark-continuation node target)))
  113.     ((primop.type self node)
  114.      '#[type (proc #f (proc #f top) template)])))
  115.  
  116. (define-constant gc-extend->pair
  117.   (primop gc-extend->pair ()
  118.     ((primop.generate self node)
  119.      (receive (source target rep) (one-arg-primitive node)
  120.          (generate-move source target)
  121.          (emit m68/add .l (machine-num 1) target) 
  122.          (mark-continuation node target)))
  123.     ((primop.type self node)
  124.      '#[type (proc #f (proc #f top) top)])))
  125. ;     '#[type (proc #f (proc #f pair) extend)])))
  126.  
  127. (define-constant gc-pair->extend
  128.   (primop gc-pair->extend ()
  129.     ((primop.generate self node)
  130.      (receive (source target rep) (one-arg-primitive node)
  131.          (generate-move source target)
  132.          (emit m68/sub .l (machine-num 1) target) 
  133.          (mark-continuation node target)))
  134.     ((primop.type self node)
  135.      '#[type (proc #f (proc #f top) top)])))
  136. ;     '#[type (proc #f (proc #f extend) pair)])))
  137.     
  138. (define-constant closure-enclosing-object
  139.   (primop closure-enclosing-object ()
  140.     ((primop.generate self node)
  141.      (generate-closure-enclosing-object node))
  142.     ((primop.type self node)
  143.      '#[type (proc #f (proc #f top) top)])))
  144. ;     '#[type (proc #f (proc #f top) extend)])))
  145.  
  146. (define-constant current-continuation
  147.   (primop current-continuation ()
  148.     ((primop.generate self node)
  149.      (generate-current-continuation node))))
  150.  
  151. (define-constant disable-interrupts
  152.   (primop disable-interrupts ()
  153.     ((primop.side-effects? self) t)
  154.     ((primop.generate self node)
  155.      (emit m68/bset (machine-num 7) (reg-offset TASK task/critical-count)))
  156.     ((primop.type self node)
  157.      '#[type (proc #f (proc #f top))])))
  158.                        
  159. (define-constant really-enable-interrupts
  160.   (primop really-enable-interrupts ()
  161.     ((primop.side-effects? self) t)
  162.     ((primop.test-code self node arg)
  163.      (emit m68/and .b (machine-num #b01111111) 
  164.                       (reg-offset TASK task/critical-count)))
  165.     ((primop.presimplify self node)
  166.      (presimplify-no-argument-predicate node))
  167.     ((primop.type self node)
  168.      '#[type (proc #f (proc #f top))])))
  169.                        
  170. (define-constant (enable-interrupts)
  171.   (if (not (really-enable-interrupts))
  172.       (handle-queued-interrupt (process-global task/critical-count))))
  173.  
  174. ; see template.doc
  175.                                                     
  176. (define-constant (bit-test operand bit)    ; true if bit is on
  177.   (if (fixnum-equal? (fixnum-logand operand (fixnum-ashl 1 bit)) 0)
  178.       '#f
  179.       '#t))
  180.  
  181. (define-constant (template-internal-bit? tem)
  182.   (let ((tem (if (fixnum-equal? (mref-16-u tem -2) m68-jump-absolute)
  183.                  (extend-pointer-elt tem 0)
  184.                  tem)))
  185.     (bit-test (mref-16-u tem -12) 0)))
  186.  
  187. (define-constant (template-superior-bit? tem) ; no cit's on stack
  188.   (bit-test (mref-16-u tem -12) 2))
  189.                                     
  190. (define-constant (template-nary? tem)
  191.   (bit-test (mref-8-u tem -4) 6))
  192.  
  193. (define-constant (template-pointer-slots tem)
  194.   (mref-8-u tem -8))
  195.  
  196. (define-constant (template-scratch-slots tem)
  197.   (mref-8-u tem -7))
  198.  
  199. (define-constant (template-nargs tem)
  200.   (mref-8-s tem -3))
  201.  
  202. (define-constant (template-encloser-offset template)
  203.   (fixnum-ashr (mref-16-u template -6) 2))
  204.  
  205. (define-constant (template-handler-offset template)
  206.   (mref-16-u template -10))
  207.  
  208. (define-constant (closure-encloser-offset closure)
  209.   (fixnum-ashr (mref-16-u (extend-header closure) -8) 2))
  210.  
  211. (define-constant (unit-top-level-forms unit)
  212.   (make-pointer unit 3))
  213.  
  214. (define-constant (alt-bit-set? extend)            ; if bit 7 of header is on
  215.   (fixnum-less? (mref-8-s extend -1) 0))
  216.  
  217. (define-constant set-alt-bit!
  218.   (primop set-alt-bit! ()
  219.     ((primop.side-effects? self) t)
  220.     ((primop.generate self node)                               
  221.      (let ((reg (->register 'pointer node (leaf-value ((call-arg 2) node)) '*)))
  222.        (emit m68/bset (machine-num 7) (reg-offset reg 1))))
  223.     ((primop.type self node)
  224.      '#[type (proc #f (proc #f top) top)])))
  225. ;     '#[type (proc #f (proc #f top) extend)])))
  226.  
  227. (define-constant clear-alt-bit!
  228.   (primop clear-alt-bit! ()
  229.     ((primop.side-effects? self) t)
  230.     ((primop.generate self node)                               
  231.      (let ((reg (->register 'pointer node (leaf-value ((call-arg 2) node)) '*)))
  232.        (emit m68/bclr (machine-num 7) (reg-offset reg 1))))
  233.     ((primop.type self node)
  234.      '#[type (proc #f (proc #f top) top)])))
  235. ;     '#[type (proc #f (proc #f top) extend)])))
  236.  
  237. (define-constant vcell-defined? alt-bit-set?)
  238.  
  239. (define-constant set-vcell-defined set-alt-bit!)
  240.  
  241. (define-constant set-vcell-undefined clear-alt-bit!)
  242.  
  243. (define-constant pure? alt-bit-set?)
  244.  
  245. (define-constant (purify! x)
  246.   (set-alt-bit! x)
  247.   (return))
  248.                        
  249. (define-constant (vframe-pointer-slots vframe)
  250.   (mref-8-u vframe -3))
  251.  
  252. (define-constant (vframe-scratch-slots vframe)
  253.   (mref-8-u vframe -2))
  254.